;;;;;; parser.scm - Scheme Syntax Analyzer module.    -*- Mode: Scheme -*-
;;;;;; Author: Erik Silkensen <silkense@colorado.edu>
;;;;;; Version: 12 Aug 2009

#lang scheme

(require "lexer.scm")

;;; This module provides a procedure ``read-datum'' that fetches the 
;;; next datum from a specified input port and returns it as a datum 
;;; object. Procedures for creating a datum object and for selecting the 
;;; attributes of a datum object are also provided. Sometimes common
;;; Scheme procedures are redefined here with a -datum suffix; hopefully
;;; such a procedure ``just works'' as one would expect it to.

;;; A datum will have one of the following names: SYMBOL, BOOLEAN, 
;;; NUMBER, CHARACTER, STRING, VECTOR, LIST, DOTTED-LIST, PAIR.

;;; This module implements something of a mix between the datum syntax 
;;; of R5RS and R6RS - maybe best described as a subset of them both.

;;; See Ch. 4.3 of the Revised^6 Report on the Algorithmic Language 
;;; Scheme for more documentation: <http://www.r6rs.org>

(provide
 parse
 read-datum
 peek-datum
 make-datum
 make-symbol-datum
 make-boolean-datum
 make-number-datum
 make-string-datum
 make-vector-datum
 make-list-datum
 make-dotted-list-datum
 make-pair-datum
 datum?
 symbol-datum?
 boolean-datum?
 number-datum?
 character-datum?
 string-datum?
 vector-datum?
 list-datum?
 pair-datum?
 dotted-list-datum?
 name-datum
 value-datum
 position-datum
 car-datum
 cdr-datum
 cons-datum
 any-list-datum?
 null-datum?
 equal?-datum
 flatten-dotted-datum
 dot-flattened-datum
 datum->syntax
 syntax-error)

(define (make-datum name value position) (list 'datum name value position))
(define (make-symbol-datum val pos) (make-datum 'SYMBOL val pos))
(define (make-boolean-datum val pos) (make-datum 'BOOLEAN val pos))
(define (make-number-datum val pos) (make-datum 'NUMBER val pos))
(define (make-character-datum val pos) (make-datum 'CHARACTER val pos))
(define (make-string-datum val pos) (make-datum 'STRING val pos))
(define (make-vector-datum val pos) (make-datum 'VECTOR val pos))
(define (make-list-datum val pos) (make-datum 'LIST val pos))
(define (make-dotted-list-datum val pos) (make-datum 'DOTTED-LIST val pos))
(define (make-pair-datum val pos) (make-datum 'PAIR val pos))

(define (name-datum datum) (cadr datum))
(define (value-datum datum) (caddr datum))
(define (position-datum datum) (cadddr datum))

(define (datum? object)
  (and (list? object)
       (not (null? object))
       (eq? (car object) 'datum)))

(define (type-datum? datum type)
  (and (datum? datum)
       (eq? (name-datum datum) type)))

(define (symbol-datum? datum) (type-datum? datum 'SYMBOL))
(define (boolean-datum? datum) (type-datum? datum 'BOOLEAN))
(define (number-datum? datum) (type-datum? datum 'NUMBER))
(define (character-datum? datum) (type-datum? datum 'CHARACTER))
(define (string-datum? datum) (type-datum? datum 'STRING))
(define (vector-datum? datum) (type-datum? datum 'VECTOR))
(define (list-datum? datum) (type-datum? datum 'LIST))
(define (dotted-list-datum? datum) (type-datum? datum 'DOTTED-LIST))
(define (pair-datum? datum) (type-datum? datum 'PAIR))

(define (any-list-datum? datum)
  (or (list-datum? datum) (dotted-list-datum? datum)))

(define (car-datum datum)
  (if (or (any-list-datum? datum)
          (pair-datum? datum))
      (car (value-datum datum))
      (error "no car for" datum)))

(define (cdr-datum datum)
  (cond ((any-list-datum? datum)
         (let* ((val (cdr (value-datum datum)))
                (pos (if (null? val) #f (position-datum (car val)))))
           (if (and (= 1 (length val))
                    (pair-datum? (car val))
                    (dotted-list-datum? datum))
               (car val)
               (make-datum (name-datum datum) val pos))))
        ((pair-datum? datum) (cdr (value-datum datum)))
        (else (error "no cdr for" datum))))

(define (cons-datum x y)
  (if (any-list-datum? y)
      (make-datum (name-datum y) (cons x (value-datum y)) (position-datum x))
      (make-pair-datum (cons x y) (position-datum x))))

(define (null-datum? datum)
  (and (any-list-datum? datum)
       (null? (value-datum datum))))

(define (equal?-datum x y)
  (equal? (value-datum x) (value-datum y)))

(define (flatten-dotted-datum datum)
  ;; (a b . c) => (a b c)
  (if (pair-datum? datum)
      (let ((val (list (car-datum datum) (cdr-datum datum))))
        (make-list-datum val (position-datum datum)))
      (cons-datum (car-datum datum)
                  (flatten-dotted-datum (cdr-datum datum)))))

(define (dot-flattened-datum datum)
  ;; (a b c) => (a b . c)
  (if (null-datum? (cdr-datum datum))
      (car-datum datum)
      (cons-datum (car-datum datum)
                  (dot-flattened-datum (cdr-datum datum)))))
  
(define (token->datum token)
  (let ((name (if (identifier-token? token) 'SYMBOL (name-token token)))
        (value (adjust-value token)))
    (make-datum name value (position-token token))))

(define (adjust-value token)
  (if (string-token? token)
      (value-token token)
      (string-downcase (value-token token))))

(define *peek* '())

(define (parse [in (current-input-port)])
  ;; Read and return a list of datum objects from an input port.
  (set! *peek* '())
  (port-count-lines! in)
  (let loop ((data '()))
    (let ((datum (read-datum in)))
      (if datum
          (loop (cons datum data))
          (reverse data)))))

(define (read-datum [in (current-input-port)])
  ;; Read and return a datum object from an input port; #f if none.
  (let ((datum (if (null? *peek*) (<datum> in) *peek*)))
    (set! *peek* '())
    datum))

(define (peek-datum [in (current-input-port)])
  ;; Return the next datum object -- without reading -- from an input
  ;; port (i.e., can be called multiple times and will return const).
  (let ((datum (if (null? *peek*) (read-datum in) *peek*)))
    (set! *peek* (if datum datum '()))
    datum))

;;; In general, if a procedure is named in <brackets>, it attempts to
;;; match and return a datum object. Others of the form match-<name>
;;; attempt to match characters, but most likely do not create a datum
;;; object.

(define (<datum> [in (current-input-port)])
  ;; The starting state for every datum. #f is returned at the end of
  ;; input, a datum object is returned if possible, and an error is
  ;; raised otherwise. <datum> -> <lexeme datum> | <compound datum>
  (let ((token (peek-token in)))
    (cond ((not token) #f)
          ((lexeme-datum? token)
           (token->datum (read-token in)))
          ((compound-datum? token)
           (<compound-datum> in))
          (else (syntax-error (read-token in))))))

(define (<compound-datum> [in (current-input-port)])
  ;; A compound datum is either a list or a vector. This procedure
  ;; assumes that the token begining the compound datum (e.g. 
  ;; LEFT-PAREN) has not been consumed. 
  ;; <compound datum> -> <list> | <vector>
  (let ((token (read-token in)))
    (cond ((list-prefix? token)
           (<list> token in))
          ((vector-prefix? token)
           (<vector> token in))
          (else (syntax-error token)))))

(define (<list> start-token [in (current-input-port)])
  ;; A list datum must match one of the rules below. Start-token should
  ;; be the token beginning the list datum (e.g. LEFT-PAREN). This
  ;; procedure assumes that start-token has already been consumed.
  ;; Dotted-pairs become PAIR datums. Abbrevations are expanded into
  ;; their list form.
  ;; <list> -> (<datum>*) | [<datum>*] | (<datum>+ . <datum>) 
  ;;           | [<datum>+ . <datum>] | <abbreviation>
  ;; <abbreviation> -> <abbrev prefix> <datum>
  ;; <abbrev prefix> -> ' | ` | , | ,@
  ;;  '<datum> => (quote <datum>)
  ;;  `<datum> => (quasiquote <datum>)
  ;;  ,<datum> => (unquote <datum>)
  ;; ,@<datum> => (unquote-splicing <datum>)
  (if (abbrev-prefix? start-token)
      (let ((abbr (expand-abbrev-prefix start-token))
            (datum (<datum> in)))
        (if datum
            (make-list-datum (list abbr datum) (position-token start-token))
            (syntax-error start-token)))
      (let* ((elements (match-datum-* '() in))
             (token (read-token in)))
        (cond ((not token) (syntax-error start-token))
              ((eq? (open->close (name-token start-token))
                    (name-token token))
               (let ((value (reverse elements)))
                 (make-list-datum value (position-token start-token))))
              ((and (not (null? elements))
                    (eq? 'DOT (name-token token)))
               (<pair> start-token elements in))
              (else (syntax-error token))))))

(define (<pair> start-token elements [in (current-input-port)])
  ;; A pair datum can optionally close a list datum (making it a dotted
  ;; list). This procedure assumes that the DOT token has already been
  ;; consumed, and that the car field of the pair is the car of elements.
  ;; Start-token should be the token beginning the list (e.g. LEFT-PAREN). 
  (let* ((datum (<datum> in))
         (value (cons (car elements) datum))
         (pair (make-pair-datum value (position-token (car elements))))
         (token (read-token in)))
    (if (and datum
             (eq? (open->close (name-token start-token))
                  (name-token token)))
        (if (null? (cdr elements))
            pair
            (let ((value (reverse (cons pair (cdr elements)))))
              (make-dotted-list-datum value (position-token start-token))))
        (syntax-error start-token))))

(define (<vector> start-token [in (current-input-port)])
  ;; <vector> -> #(<datum>*)
  (let* ((elements (match-datum-* '() in))
         (token (read-token in)))
    (if (eq? 'RIGHT-PAREN (name-token token))
        (let ((value (reverse elements)))
          (make-datum 'VECTOR value (position-token start-token)))
        (syntax-error token))))

(define (match-datum-* data [in (current-input-port)])
  ;; Attempts to match zero or more datum objects. Data is a list,
  ;; initially empty, of the datum objects that are matched at any
  ;; iteration of match-datum-*.
  (let ((token (peek-token in)))
    (cond ((not token) data)
          ((lexeme-datum? token)
           (match-datum-* (cons (token->datum (read-token in)) data) in))
          ((compound-datum? token)
           (match-datum-* (cons (<compound-datum> in) data) in))
          (else data))))

(define (lexeme-datum? token)
  (case (name-token token)
    ((BOOLEAN NUMBER CHARACTER STRING IDENTIFIER) #t)
    (else #f)))

(define (compound-datum? token)
  (or (list-prefix? token)
      (vector-prefix? token)))

(define (list-prefix? token)
  (case (name-token token)
    ((LEFT-PAREN LEFT-BRACKET) #t)
    (else (abbrev-prefix? token))))

(define (vector-prefix? token)
  (eq? 'VECTOR (name-token token)))

(define (abbrev-prefix? token)
  (case (name-token token)
    ((SINGLE-QUOTE BACKQUOTE COMMA COMMA-AT) #t)
    (else #f)))

(define (expand-abbrev-prefix token)
  (make-datum
   'SYMBOL
   (case (name-token token)
     ((SINGLE-QUOTE) "quote")
     ((BACKQUOTE) "quasiquote")
     ((COMMA) "unquote")
     ((COMMA-AT) "unquote-splicing")
     (else (symbol->string (name-token token))))
   (position-token token)))

(define (open->close symbol)
  ;; Returns a corresponding close symbol for the open one provided
  ;; (e.g. left parens open a sequence that is closed with a right
  ;; paren).
  (cond ((eq? 'LEFT-PAREN symbol) 'RIGHT-PAREN)
        ((eq? 'LEFT-BRACKET symbol) 'RIGHT-BRACKET)
        (else symbol)))

(define (datum->syntax obj)
  (define (dot x) (if (null? (cdr x)) (car x) (cons (car x) (dot (cdr x)))))
  (cond ((symbol-datum? obj) (string->symbol (value-datum obj)))
        ((boolean-datum? obj) (if (string=? "#t" (value-datum obj)) #t #f))
        ((number-datum? obj) (string->number (value-datum obj)))
        ((character-datum? obj)
         (let ((char (value-datum obj)))
           (cond ((string=? "#\\space") #\space)
                 ((string=? "#\\newline") #\newline)
                 (else (string-ref char 2)))))
        ((string-datum? obj) (value-datum obj))
        ((vector-datum? obj) `#(,@(map datum->syntax (value-datum obj))))
        ((dotted-list-datum? obj) (dot (map datum->syntax (value-datum obj))))
        ((list-datum? obj) (map datum->syntax (value-datum obj)))
        ((pair-datum? obj)
         (let ((pair (value-datum obj)))
           (cons (datum->syntax (car pair))
                 (datum->syntax (cdr pair)))))
        (else obj)))

(define (syntax-error datum [message ""])
  (raise-user-error (format "bad syntax: ~a on line ~a near: ~a"
                            message
                            (car (position-datum datum))
                            (pretty-format (datum->syntax datum)))))
